module Comp

open System.IO
open Absyn
open Machine
open Debug

(* ------------------------------------------------------------------- *)

(* Simple environment operations *)

type 'data Env = (string * 'data) list

let rec lookup env x =
    match env with
    | [] -> failwith (x + " not found")
    | (y, v) :: yr -> if x = y then v else lookup yr x

(* A global variable has an absolute address, a local one has an offset: *)

type Var =
    | Glovar of int (* absolute address in stack           *)
    | Locvar of int (* address relative to bottom of frame *)

(* The variable environment keeps track of global and local variables, and
   keeps track of next available offset for local variables *)

type VarEnv = (Var * typ) Env * int

(* The function environment maps function name to label and parameter decs *)

type Paramdecs = (typ * string) list

type FunEnv = (label * typ option * Paramdecs) Env

(* Bind declared variable in env and generate code to allocate it: *)

let allocate (kind: int -> Var) (typ, x) (varEnv: VarEnv) : VarEnv * instr list =
    printf "allocate called!\n"
    let (env, fdepth) = varEnv

    match typ with
    | TypeArray (TypeArray _, _) -> raise (Failure "allocate: array of arrays not permitted")
    | TypeArray (t, Some i) ->
        let newEnv =
            ((x, (kind (fdepth + i), typ)) :: env, fdepth + i + 1) //数组占用 i个位置

        let code = [ INCSP i; GETSP; CSTI(i - 1); SUB ]
        (newEnv, code)
    | _ ->
        let newEnv =
            ((x, (kind (fdepth), typ)) :: env, fdepth + 1)

        let code = [ INCSP 1 ]

        printf "new varEnv: %A\n" newEnv // 调试 显示分配后环境变化
        (newEnv, code)

(* Bind declared parameters in env: *)

let bindParam (env, fdepth) (typ, x) : VarEnv =
    ((x, (Locvar fdepth, typ)) :: env, fdepth + 1)

let bindParams paras ((env, fdepth): VarEnv) : VarEnv = List.fold bindParam (env, fdepth) paras

(* ------------------------------------------------------------------- *)

(* Build environments for global variables and functions *)

let makeGlobalEnvs (topdecs: topdec list) : VarEnv * FunEnv * instr list =
    let rec addv decs varEnv funEnv =
        info (fun () -> printf "Global funEnv: %A\n" funEnv)

        match decs with
        | [] -> (varEnv, funEnv, [])
        | dec :: decr ->
            match dec with
            | Vardec (typ, var) ->
                let (varEnv1, code1) = allocate Glovar (typ, var) varEnv
                let (varEnvr, funEnvr, coder) = addv decr varEnv1 funEnv
                (varEnvr, funEnvr, code1 @ coder)
            | VardecAndAssign (typ, x, e) ->
                let (varEnv1, code1) = allocate Glovar (typ, x) varEnv
                let (varEnvr, funEnvr, coder) = addv decr varEnv1 funEnv
                (varEnvr, funEnvr, code1 @ coder)
            | Fundec (tyOpt, f, xs, body) -> addv decr varEnv ((f, (newLabel (), tyOpt, xs)) :: funEnv)

    addv topdecs ([], 0) []

(* ------------------------------------------------------------------- *)

(* Compiling micro-C statements:
   * stmt    is the statement to compile
   * varenv  is the local and global variable environment
   * funEnv  is the global function environment
*)

let rec cStmt stmt (varEnv: VarEnv) (funEnv: FunEnv) : instr list =
    match stmt with
    | If (e, stmt1, stmt2) ->
        let labelse = newLabel ()
        let labend = newLabel ()

        cExpr e varEnv funEnv
        @ [ IFZERO labelse ]
          @ cStmt stmt1 varEnv funEnv
            @ [ GOTO labend ]
              @ [ Label labelse ]
                @ cStmt stmt2 varEnv funEnv @ [ Label labend ]
    | While (e, body) ->
        let labbegin = newLabel ()
        let labtest = newLabel ()

        [ GOTO labtest; Label labbegin ]
        @ cStmt body varEnv funEnv
          @ [ Label labtest ]
            @ cExpr e varEnv funEnv @ [ IFNZRO labbegin ]
    | For (dec, e, oper, body) ->
        let labtest = newLabel () // 把oper 和body看成一个整体,操作和上面while是一样的
        let labbegin = newLabel ()
        let (varEnv1, code) = cStmtOrDec dec varEnv funEnv

        code
        @ [ GOTO labtest; Label labbegin ]
          @ cStmt body varEnv1 funEnv
            @ cExpr oper varEnv1 funEnv
              @ [ INCSP -1 ]
                @ [ Label labtest ]
                  @ cExpr e varEnv1 funEnv
                    @ [ IFNZRO labbegin
                        INCSP(snd varEnv - snd varEnv1) ]
    | Expr e -> cExpr e varEnv funEnv @ [ INCSP -1 ]
    | Switch (e, cases) ->
        let rec everycase c =
            match c with
            | Case (cond, body) :: tail ->
                let labend = newLabel ()
                let labfin = newLabel ()

                [ DUP ]
                @ cExpr cond varEnv funEnv
                  @ [ EQ ]
                    @ [ IFZERO labend ]
                      @ cStmt body varEnv funEnv
                        @ [ GOTO labfin ]
                          @ [ Label labend ]
                            @ everycase tail @ [ Label labfin ]
            | [] -> []

        cExpr e varEnv funEnv
        @ everycase cases @ [ INCSP -1 ]
    | Try (stmt, catches) ->
        let expList = [ Exception "ArithmeticException" ; Exception "NullPointerException"]
        //在异常列表中查询异常,并返回位置
        let rec lookupExp e (expList: myexception list) edepth =
            match expList with
            | front :: tail ->
                if e = front then
                    edepth
                else
                    lookupExp e tail edepth + 1
            | [] -> failwith "Program dont support this type exception"

        //先遍历一遍所有的catch,每次都声明异常对象,最后把varEnv传入stmt执行
        //定义一个异常对象,包括三个属性__exception.type,__exception.code,__exception.hr
        //hr指向的位置表示某个异常
        //当前hr位置的类型不对 ,hr=hr+2位置的值
        let rec everycatch c varEnv1=
            match c with
            | Catch (exp, body) :: tail ->
                let labbody = newLabel ()
                let labend = newLabel ()
                let expPos = lookupExp exp expList 1

                let (varEnv2, code1) =
                    cStmtOrDec (DeclareAndAssign(TypeInt, "__exception.type", ConstInt expPos)) varEnv1 funEnv

                let (varEnv3, code2) =
                    cStmtOrDec (Dec(TypeInt, "__exception.code")) varEnv2 funEnv

                let (varEnvEnd, code3) =
                    cStmtOrDec (Dec(TypeInt, "__exception.hr")) varEnv3 funEnv
                code1
                  @ code2
                    @ code3
                      @ [ NOTICEEX; PUSHHDLR labbody]
                        @ everycatch tail varEnvEnd
                          @ [ GOTO labend ]
                            @ [ Label labbody ] @ cStmt body varEnvEnd funEnv
                            @[Label labend]
            | [] -> cStmt stmt varEnv1 funEnv

        everycatch catches varEnv
    | Block stmts ->

        let rec loop stmts varEnv =
            match stmts with
            | [] -> (snd varEnv, [])
            | s1 :: sr ->
                let (varEnv1, code1) = cStmtOrDec s1 varEnv funEnv
                let (fdepthr, coder) = loop sr varEnv1
                (fdepthr, code1 @ coder)

        let (fdepthend, code) = loop stmts varEnv

        code @ [ INCSP(snd varEnv - fdepthend) ]

    | Return None -> [ RET(snd varEnv - 1) ]
    | Return (Some e) -> cExpr e varEnv funEnv @ [ RET(snd varEnv) ]

and cStmtOrDec stmtOrDec (varEnv: VarEnv) (funEnv: FunEnv) : VarEnv * instr list =
    match stmtOrDec with
    | Stmt stmt -> (varEnv, cStmt stmt varEnv funEnv)
    | Dec (typ, x) -> allocate Locvar (typ, x) varEnv
    //  声明并赋值,比起上一个多了一步
    //调用cExpr的赋值语句
    | DeclareAndAssign (typ, x, e) ->
        let (varEnv, code) = allocate Locvar (typ, x) varEnv

        (varEnv,
         code
         @ (cExpr (Assign((AccVar x), e)) varEnv funEnv)
           @ [ INCSP -1 ])


(* Compiling micro-C expressions:

   * e       is the expression to compile
   * varEnv  is the local and gloval variable environment
   * funEnv  is the global function environment

   Net effect principle: if the compilation (cExpr e varEnv funEnv) of
   expression e returns the instruction sequence instrs, then the
   execution of instrs will leave the rvalue of expression e on the
   stack top (and thus extend the current stack frame with one element).
*)

and cExpr (e: expr) (varEnv: VarEnv) (funEnv: FunEnv) : instr list =
    match e with
    | Access acc -> cAccess acc varEnv funEnv @ [ LDI ]
    | Assign (acc, e) ->
        cAccess acc varEnv funEnv
        @ cExpr e varEnv funEnv @ [ STI ]
    | ConstInt i -> [ CSTI i ]
    | ConstDouble i ->
        [ CSTD(
              System.BitConverter.ToInt32((System.BitConverter.GetBytes(i)), 4),
              System.BitConverter.ToInt32((System.BitConverter.GetBytes(i)), 0)
          ) ]
    | ConstLong i ->
        [ CSTL(
              System.BitConverter.ToInt32((System.BitConverter.GetBytes(i)), 4),
              System.BitConverter.ToInt32((System.BitConverter.GetBytes(i)), 0)
          ) ]
    | ConstFloat i -> [ CSTF(System.BitConverter.ToInt32((System.BitConverter.GetBytes(float32 (i))), 0)) ]
    | ConstChar i -> [ CSTC((int32) (System.BitConverter.ToInt16((System.BitConverter.GetBytes(char (i))), 0))) ]
    | Addr acc -> cAccess acc varEnv funEnv
    | Prim1 (ope, e1) ->
        //在表达式(expr)里面取出变量(AccVar "x")
        let rec tmp stat =
            match stat with
            | Access (c) -> c
            | _ -> failwith ("error")

        cExpr e1 varEnv funEnv
        @ (match ope with
           | "!" -> [ NOT ]
           | "printi" -> [ PRINTI ]
           | "printc" -> [ PRINTC ]
           | "I++" ->
               [ CSTI 1; ADD ]
               @ cAccess (tmp e1) varEnv funEnv
                 @ [ SWAP; STI; CSTI -1; ADD ]
           | "I--" ->
               [ CSTI -1; ADD ]
               @ cAccess (tmp e1) varEnv funEnv
                 @ [ SWAP; STI; CSTI 1; ADD ]
           | "++I" ->
               [ CSTI 1; ADD ]
               @ cAccess (tmp e1) varEnv funEnv @ [ SWAP; STI ]
           | "--I" ->
               [ CSTI -1; ADD ]
               @ cAccess (tmp e1) varEnv funEnv @ [ SWAP; STI ]
           | _ -> raise (Failure "unknown primitive 1"))
    | Prim2 (ope, e1, e2) ->
        cExpr e1 varEnv funEnv
        @ cExpr e2 varEnv funEnv
          @ (match ope with
             | "*" -> [ MUL ]
             | "+" -> [ ADD ]
             | "-" -> [ SUB ]
             | "/" -> [ DIV ]
             | "%" -> [ MOD ]
             | "==" -> [ EQ ]
             | "!=" -> [ EQ; NOT ]
             | "<" -> [ LT ]
             | ">=" -> [ LT; NOT ]
             | ">" -> [ SWAP; LT ]
             | "<=" -> [ SWAP; LT; NOT ]
             | _ -> raise (Failure "unknown primitive 2"))
    | Prim3 (cond, e1, e2) ->
        let labelse = newLabel ()
        let labend = newLabel ()

        cExpr cond varEnv funEnv
        @ [ IFZERO labelse ]
          @ cExpr e1 varEnv funEnv
            @ [ GOTO labend ]
              @ [ Label labelse ]
                @ cExpr e2 varEnv funEnv @ [ Label labend ]
    | Andalso (e1, e2) ->
        let labend = newLabel ()
        let labfalse = newLabel ()

        cExpr e1 varEnv funEnv
        @ [ IFZERO labfalse ]
          @ cExpr e2 varEnv funEnv
            @ [ GOTO labend
                Label labfalse
                CSTI 0
                Label labend ]
    | Orelse (e1, e2) ->
        let labend = newLabel ()
        let labtrue = newLabel ()

        cExpr e1 varEnv funEnv
        @ [ IFNZRO labtrue ]
          @ cExpr e2 varEnv funEnv
            @ [ GOTO labend
                Label labtrue
                CSTI 1
                Label labend ]
    | Call (f, es) -> callfun f es varEnv funEnv
    | Max(e1, e2) ->
      let labtrue = newLabel()
      let labend = newLabel()
      cExpr e1 varEnv funEnv @ cExpr e2 varEnv funEnv @ [LT] @ [IFNZRO labtrue]
      @ cExpr e1 varEnv funEnv @ [GOTO labend;Label labtrue] @ cExpr e2 varEnv funEnv
      @ [Label labend]
    | Min(e1, e2) ->
      let labtrue = newLabel()
      let labend = newLabel()
      cExpr e1 varEnv funEnv @ cExpr e2 varEnv funEnv @ [LT] @ [IFNZRO labtrue]
      @ cExpr e2 varEnv funEnv @ [GOTO labend;Label labtrue] @ cExpr e1 varEnv funEnv
      @ [Label labend]
    | Abs(e) ->
      let lab1 = newLabel()
      let lab2 = newLabel()
      cExpr e varEnv funEnv @ [CSTI 0] @ [LT] @ [IFNZRO lab1] @ cExpr e varEnv funEnv
      @ [GOTO lab2;Label lab1] @ cExpr e varEnv funEnv @ [NEG] @ [Label lab2]


(* Generate code to access variable, dereference pointer or index array.
   The effect of the compiled code is to leave an lvalue on the stack.   *)

and cAccess access varEnv funEnv : instr list =
    match access with
    | AccVar x ->
        match lookup (fst varEnv) x with
        //注意,这里的CSTI是放入地址,不需要和其他类型并列
        | Glovar addr, _ -> [ CSTI addr ]
        | Locvar addr, _ -> [ GETBP; CSTI addr; ADD ]
    | AccDeref e -> cExpr e varEnv funEnv
    | AccIndex (acc, idx) ->
        cAccess acc varEnv funEnv
        @ [ LDI ] @ cExpr idx varEnv funEnv @ [ ADD ]

(* Generate code to evaluate a list es of expressions: *)

and cExprs es varEnv funEnv : instr list =
    List.concat (List.map (fun e -> cExpr e varEnv funEnv) es)

(* Generate code to evaluate arguments es and then call function f: *)

and callfun f es varEnv funEnv : instr list =
    let (labf, tyOpt, paramdecs) = lookup funEnv f
    let argc = List.length es

    if argc = List.length paramdecs then
        cExprs es varEnv funEnv @ [ CALL(argc, labf) ]
    else
        raise (Failure(f + ": parameter/argument mismatch"))


(* Compile a complete micro-C program: globals, call to main, functions *)

let cProgram (Prog topdecs) : instr list =
    let _ = resetLabels ()
    let ((globalVarEnv, _), funEnv, globalInit) = makeGlobalEnvs topdecs

    let compilefun (tyOpt, f, xs, body) =
        let (labf, _, paras) = lookup funEnv f
        let (envf, fdepthf) = bindParams paras (globalVarEnv, 0)
        let code = cStmt body (envf, fdepthf) funEnv

        [ Label labf ]
        @ code @ [ RET(List.length paras - 1) ]

    let functions =
        List.choose
            (function
            | Fundec (rTy, name, argTy, body) -> Some(compilefun (rTy, name, argTy, body))
            | Vardec _ -> None)
            topdecs

    let (mainlab, _, mainparams) = lookup funEnv "main"
    let argc = List.length mainparams

    globalInit
    @ [ LDARGS; CALL(argc, mainlab); STOP ]
      @ List.concat functions

(* Compile a complete micro-C and write the resulting instruction list
   to file fname; also, return the program as a list of instructions.
 *)

let intsToFile (inss: int list) (fname: string) =
    File.WriteAllText(fname, String.concat " " (List.map string inss))

let compileToFile program fname =

    info (fun () -> printfn "program:\n %A" program)

    let instrs = cProgram program
    info (fun () -> printfn "\nStack VM instrs: %A\n" instrs)

    let bytecode = code2ints instrs
    info (fun () -> printfn "Stack VM numeric code: %A\n" bytecode)

    // let deinstrs = decomp bytecode
    // printf "deinstrs: %A\n" deinstrs

    intsToFile bytecode fname
    instrs

(* Example programs are found in the files ex1.c, ex2.c, etc *)
